home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / defclass.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  20.7 KB  |  572 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'.
  32. ;;;
  33. ;;; The original motiviation for this function was to deal with the bug in
  34. ;;; the Genera compiler that prevents lambda expressions in top-level forms
  35. ;;; other than DEFUN from being compiled.
  36. ;;;
  37. ;;; Now this function is used to grab other functionality as well.  This
  38. ;;; includes:
  39. ;;;   - Preventing the grouping of top-level forms.  For example, a
  40. ;;;     DEFCLASS followed by a DEFMETHOD may not want to be grouped
  41. ;;;     into the same top-level form.
  42. ;;;   - Telling the programming environment what the pretty version
  43. ;;;     of the name of this form is.  This is used by WARN.
  44. ;;; 
  45. (defun make-top-level-form (name times form)
  46.   (flet ((definition-name ()
  47.        (if (and (listp name)
  48.             (memq (car name) '(defmethod defclass class method method-combination)))
  49.            (format nil "~A~{ ~S~}"
  50.                (capitalize-words (car name) ()) (cdr name))
  51.            (format nil "~S" name))))
  52.     (definition-name)
  53.     #+Genera
  54.     (progn
  55.       #-Genera-Release-8
  56.       (let ((thunk-name (gensym "TOP-LEVEL-FORM")))
  57.     `(eval-when ,times
  58.        (defun ,thunk-name ()
  59.          (declare (sys:function-parent
  60.             ,(cond ((listp name)
  61.                 (case (first name)
  62.                   (defmethod `(method ,@(rest name)))
  63.                   (otherwise (second name))))
  64.                    (t name))
  65.             ,(cond ((listp name)
  66.                 (case (first name)
  67.                   ((defmethod defgeneric) 'defun)
  68.                   ((defclass) 'defclass)
  69.                   (otherwise (first name))))
  70.                    (t 'defun))))
  71.          ,form)
  72.        (,thunk-name)))
  73.       #+Genera-Release-8
  74.       `(compiler-let ((compiler:default-warning-function ',name))
  75.      (eval-when ,times
  76.        (funcall #'(lambda ()
  77.             (declare ,(cond ((listp name)
  78.                      (case (first name)
  79.                        ((defclass)
  80.                         `(sys:function-parent ,(second name) defclass))
  81.                        ((defmethod)
  82.                         `(sys:function-name (method ,@(rest name))))
  83.                        ((defgeneric)
  84.                         `(sys:function-name ,(second name)))
  85.                        (otherwise
  86.                          `(sys:function-name ,name))))
  87.                     (t
  88.                      `(sys:function-name ,name))))
  89.             ,form)))))
  90.     #+LCL3.0
  91.     `(compiler-let ((lucid::*compiler-message-string*
  92.               (or lucid::*compiler-message-string*
  93.               ,(definition-name))))
  94.        (eval-when ,times ,form))
  95.     #+cmu
  96.     (if (member 'compile times)
  97.         `(eval-when ,times ,form)
  98.         form)
  99.     #+kcl
  100.     (let* ((*print-pretty* nil)
  101.            (thunk-name (gensym (definition-name))))
  102.       (gensym "G") ; set the prefix back to something less confusing.
  103.       `(eval-when ,times
  104.          (defun ,thunk-name ()
  105.            ,form)
  106.          (,thunk-name)))
  107.     #-(or Genera LCL3.0 cmu kcl)
  108.     (make-progn `',name `(eval-when ,times ,form))))
  109.  
  110. (defun make-progn (&rest forms)
  111.   (let ((progn-form nil))
  112.     (labels ((collect-forms (forms)
  113.            (unless (null forms)
  114.          (collect-forms (cdr forms))
  115.          (if (and (listp (car forms))
  116.               (eq (caar forms) 'progn))
  117.              (collect-forms (cdar forms))
  118.              (push (car forms) progn-form)))))
  119.       (collect-forms forms)
  120.       (cons 'progn progn-form))))
  121.  
  122.  
  123.  
  124. ;;; 
  125. ;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed.
  126. ;;; DEFCLASS always expands into a call to LOAD-DEFCLASS.  Until the meta-
  127. ;;; braid is set up, LOAD-DEFCLASS has a special definition which simply
  128. ;;; collects all class definitions up, when the metabraid is initialized it
  129. ;;; is done from those class definitions.
  130. ;;;
  131. ;;; After the metabraid has been setup, and the protocol for defining classes
  132. ;;; has been defined, the real definition of LOAD-DEFCLASS is installed by the
  133. ;;; file defclass.lisp
  134. ;;; 
  135. (defmacro DEFCLASS (name direct-superclasses direct-slots &rest options)
  136.   (declare (indentation 2 4 3 1))
  137.   (expand-defclass name direct-superclasses direct-slots options))
  138.  
  139. (defun expand-defclass (name supers slots options)
  140.   (declare (special *defclass-times* *boot-state* *the-class-structure-class*))
  141.   (setq supers  (copy-tree supers)
  142.     slots   (copy-tree slots)
  143.     options (copy-tree options))
  144.   (let ((metaclass 'standard-class))
  145.     (dolist (option options)
  146.       (if (not (listp option))
  147.           (error "~S is not a legal defclass option." option)
  148.           (when (eq (car option) ':metaclass)
  149.             (unless (legal-class-name-p (cadr option))
  150.               (error "The value of the :metaclass option (~S) is not a~%~
  151.                       legal class name."
  152.                      (cadr option)))
  153.             (setq metaclass (cadr option))
  154.         (setf options (remove option options))
  155.         (return t))))
  156.  
  157.     (let ((*initfunctions* ())
  158.           (*accessors* ())                         ;Truly a crock, but we got
  159.           (*readers* ())                           ;to have it to live nicely.
  160.           (*writers* ()))
  161.       (declare (special *initfunctions* *accessors* *readers* *writers*))
  162.       (let* ((canonical-slots
  163.            (mapcar #'(lambda (spec)
  164.                (canonicalize-slot-specification name spec))
  165.                slots))
  166.          (other-initargs
  167.            (mapcar #'(lambda (option)
  168.                (canonicalize-defclass-option name option))
  169.                options))
  170.           (defstruct-p (and (eq *boot-state* 'complete)
  171.                     (let ((mclass (find-class metaclass nil)))
  172.                   (and mclass
  173.                        (*subtypep mclass 
  174.                           *the-class-structure-class*))))))
  175.     (do-standard-defsetfs-for-defclass *accessors*)
  176.         (let ((defclass-form 
  177.                  (make-top-level-form `(defclass ,name)
  178.                    *defclass-times*
  179.            `(progn
  180.               ,@(mapcar #'(lambda (x)
  181.                                     `(proclaim-defgeneric ',x '(self)))
  182.                 *readers*)
  183.               ,@(mapcar #'(lambda (x)
  184.                     #-setf (when (consp x)
  185.                          (setq x (get-setf-function-name (cadr x))))
  186.                                     `(proclaim-defgeneric ',x '(new self)))
  187.                 *writers*)
  188.               (let ,(mapcar #'cdr *initfunctions*)
  189.             (load-defclass ',name
  190.                        ',metaclass
  191.                        ',supers
  192.                        (list ,@canonical-slots)
  193.                        (list ,@(apply #'append 
  194.                               (when defstruct-p
  195.                             '(:from-defclass-p t))
  196.                               other-initargs))
  197.                        ',*accessors*))))))
  198.           defclass-form)))))
  199.  
  200. (defun float-zero ()
  201.   0.0)
  202.  
  203. (defun make-initfunction (initform)
  204.   (declare (special *initfunctions*))
  205.   (cond ((or (eq initform 't)
  206.          (equal initform ''t))
  207.      '(function true))
  208.     ((or (eq initform 'nil)
  209.          (equal initform ''nil))
  210.      '(function false))
  211.     ((or (eql initform '0)
  212.          (equal initform ''0))
  213.      '(function zero))
  214.     ((or (eql initform '0.0)
  215.          (equal initform ''0.0))
  216.      '(function float-zero))
  217.     (t
  218.      (let ((entry (assoc initform *initfunctions* :test #'equal)))
  219.        (unless entry
  220.          (setq entry
  221.                    (list initform
  222.              (gensym)
  223.                          `(slot-initfunction-storage-form
  224.                             (function (lambda () ,initform)))))
  225.          (push entry *initfunctions*))
  226.        (cadr entry)))))
  227.  
  228. (defun canonicalize-slot-specification (class-name spec)
  229.   (declare (special *accessors* *readers* *writers*))
  230.   (cond ((and (symbolp spec)
  231.           (not (keywordp spec))
  232.           (not (memq spec '(t nil))))           
  233.      `'(:name ,spec))
  234.     ((not (consp spec))
  235.      (error "~S is not a legal slot specification." spec))
  236.     ((null (cdr spec))
  237.      `'(:name ,(car spec)))
  238.     ((null (cddr spec))
  239.      (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
  240.                  Convert it to ~S"
  241.         class-name spec (list (car spec) :initform (cadr spec))))
  242.     (t
  243.      (let* ((name (pop spec))
  244.         (readers ())
  245.         (writers ())
  246.         (initargs ())
  247.         (unsupplied (list nil))
  248.         (initform (getf spec :initform unsupplied)))
  249.        (doplist (key val) spec
  250.          (case key
  251.            (:accessor (push val *accessors*)
  252.               (push val readers)
  253.               (push `(setf ,val) writers))
  254.            (:reader   (push val readers))
  255.            (:writer   (push val writers))
  256.            (:initarg  (push val initargs))))
  257.        (loop (unless (remf spec :accessor) (return)))
  258.        (loop (unless (remf spec :reader)   (return)))
  259.        (loop (unless (remf spec :writer)   (return)))
  260.        (loop (unless (remf spec :initarg)  (return)))
  261.            (setq *writers* (append writers *writers*))
  262.            (setq *readers* (append readers *readers*))
  263.        (setq spec `(:name     ',name
  264.             :readers  ',readers
  265.             :writers  ',writers
  266.             :initargs ',initargs
  267.             ',spec))
  268.        (if (eq initform unsupplied)
  269.            `(list* ,@spec)
  270.            `(list* :initfunction ,(make-initfunction initform)
  271.                        :initfunction-side-effect-free-p ,(simple-eval-access-p initform)
  272.                        ,@spec))))))
  273.  
  274. (defun canonicalize-defclass-option (class-name option)  
  275.   (declare (ignore class-name))
  276.   (case (car option)
  277.     (:default-initargs
  278.       (let ((canonical ()))
  279.     (let (key val (tail (cdr option)))
  280.       (loop (when (null tail) (return nil))
  281.         (setq key (pop tail)
  282.               val (pop tail))
  283.         (push ``(,',key ,,(make-initfunction val) ,',val) canonical))
  284.       `(':direct-default-initargs (list ,@(nreverse canonical))))))
  285.     (:documentation
  286.       `(:documentation ',(cadr option)))
  287.     (otherwise
  288.       `(',(car option) ',(cdr option)))))
  289.  
  290.  
  291. ;;;
  292. ;;; This is the early definition of load-defclass.  It just collects up all
  293. ;;; the class definitions in a list.  Later, in the file braid1.lisp, these
  294. ;;; are actually defined.
  295. ;;;
  296.  
  297.  
  298. ;;;
  299. ;;; Each entry in *early-class-definitions* is an early-class-definition.
  300. ;;; 
  301. ;;;
  302. (declaim (type list *early-class-definitions*))
  303. (defparameter *early-class-definitions* ())
  304.  
  305. (defun make-early-class-definition
  306.        (name source metaclass
  307.     superclass-names canonical-slots other-initargs)
  308.   (list 'early-class-definition
  309.     name source metaclass
  310.     superclass-names canonical-slots other-initargs))
  311.   
  312. (defun ecd-class-name        (ecd) (nth 1 ecd))
  313. (defun ecd-source            (ecd) (nth 2 ecd))
  314. (defun ecd-metaclass         (ecd) (nth 3 ecd))
  315. (defun ecd-superclass-names  (ecd) (nth 4 ecd))
  316. (defun ecd-canonical-slots   (ecd) (nth 5 ecd))
  317. (defun ecd-other-initargs    (ecd) (nth 6 ecd))
  318.  
  319. (proclaim '(notinline load-defclass))
  320. (defun load-defclass
  321.        (name metaclass supers canonical-slots canonical-options accessor-names)
  322.   (setq supers  (copy-tree supers)
  323.     canonical-slots   (copy-tree canonical-slots)
  324.     canonical-options (copy-tree canonical-options))
  325.   (do-standard-defsetfs-for-defclass accessor-names)
  326.   (when (eq metaclass 'standard-class)
  327.     (inform-type-system-about-std-class name))
  328.   (let ((ecd
  329.       (make-early-class-definition name
  330.                        (load-truename)
  331.                        metaclass
  332.                        supers
  333.                        canonical-slots
  334.                        (apply #'append canonical-options)))
  335.     (existing
  336.       (find name *early-class-definitions* :key #'ecd-class-name)))
  337.     (setq *early-class-definitions*
  338.       (cons ecd (remove existing *early-class-definitions*)))
  339.     ecd))
  340.  
  341. ;;;
  342. ;;; FIND-CLASS
  343. ;;;
  344. ;;; This is documented in the CLOS specification.
  345. ;;;
  346. (defvar *find-class* (make-hash-table :test #'eq))
  347.  
  348. (defmacro find-class-cell-class (cell)
  349.   `(car ,cell))
  350.  
  351. (defmacro find-class-cell-predicate (cell)
  352.   `(cdr ,cell))
  353.  
  354. (defun find-class-cell (symbol &optional dont-create-p)
  355.   (or (gethash symbol *find-class*)
  356.       (unless dont-create-p
  357.     (unless (legal-class-name-p symbol)
  358.       (error "~S is not a legal class name." symbol))
  359.     (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
  360.  
  361. (defun found-unknown-class (symbol errorp)
  362.   (cond ((null errorp) nil)
  363.         ((legal-class-name-p symbol)
  364.          (error "No class named: ~S." symbol))
  365.         (t
  366.          (error "~S is not a legal class name." symbol))))
  367.  
  368. (defmacro find-class-from-cell (symbol cell &optional (errorp t))
  369.   `(or (find-class-cell-class ,cell)
  370.        (if (known-structure-type-p ,symbol)
  371.            (find-structure-class ,symbol)
  372.            #+structure-functions
  373.            (found-unknown-class ,symbol ,errorp)
  374.            #-structure-functions
  375.            (find-maybe-structure-class ,symbol ,errorp))))
  376.  
  377. #-structure-functions
  378. (defun likely-to-name-structure-p (symbol)
  379.   ;; Returns whether Symbol is likely to name an already-defined
  380.   ;; structure by whether it can find the default make or predicate
  381.   ;; functions that would have been created by Defstruct.  This
  382.   ;; obviously may fail.
  383.   (let ((name (symbol-name symbol)))
  384.     (declare (type simple-string name))
  385.     (and (fboundp (intern (concatenate 'simple-string "MAKE-" name)
  386.                           (symbol-package symbol)))
  387.          (fboundp (intern (concatenate 'simple-string name "-P")
  388.                           (symbol-package symbol))))))
  389.  
  390. #-structure-functions
  391. (defun find-maybe-structure-class (symbol errorp)
  392.   (if symbol
  393.       (multiple-value-bind (structurep surep)
  394.            (safe-subtypep symbol 'structure)
  395.         (declare (type boolean structurep surep))
  396.         (if structurep
  397.             (find-structure-class symbol :warn T)
  398.             (if surep
  399.                 (found-unknown-class symbol errorp)
  400.                 (if (likely-to-name-structure-p symbol)
  401.                     (find-structure-class symbol :warn T)
  402.                     (found-unknown-class symbol errorp)))))
  403.      (found-unknown-class symbol errorp)))
  404.  
  405. (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
  406.   (unless (find-class-cell-class cell)
  407.     (find-class-from-cell symbol cell errorp))
  408.   (find-class-cell-predicate cell))
  409.  
  410. (defun legal-class-name-p (x)
  411.   (and (symbolp x)
  412.        (not (keywordp x))))
  413.  
  414. (defun find-class (symbol &optional (errorp t) environment)
  415.   (declare (ignore environment))
  416.   (find-class-from-cell symbol (gethash symbol *find-class*) errorp))
  417.  
  418. (defun find-class-predicate (symbol &optional (errorp t) environment)
  419.   (declare (ignore environment))
  420.   (find-class-predicate-from-cell symbol (find-class-cell symbol errorp) errorp))
  421.  
  422. #-setf
  423. (defsetf find-class (symbol &optional (errorp t) environment) (new-value)
  424.   (declare (ignore errorp environment))
  425.   `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol))
  426.  
  427. (defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol)
  428.   (if (legal-class-name-p symbol)
  429.       (setf (find-class-cell-class (find-class-cell symbol)) new-value)
  430.       (error "~S is not a legal class name." symbol)))
  431.  
  432. #-setf
  433. (defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)
  434.   (declare (ignore errorp environment))
  435.   `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))
  436.  
  437. (defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate)
  438.           (new-value symbol)
  439.   (if (legal-class-name-p symbol)
  440.       (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
  441.       (error "~S is not a legal class name." symbol)))
  442.  
  443. (defun make-find-class-cell (class-name)
  444.   (cons nil
  445.         #'(lambda (x)
  446.             (let* ((class (find-class class-name))
  447.                    (class-predicate (make-class-predicate class)))
  448.               (declare (type compiled-function class-predicate))
  449.               (setf (find-class-predicate class-name) class-predicate)
  450.               (funcall class-predicate x)))))
  451.  
  452. (defun find-wrapper (symbol)
  453.   (class-wrapper (find-class symbol)))
  454.  
  455.  
  456.  
  457.  
  458. (declaim (ftype (function (T)
  459.                   (values index index boolean boolean boolean list list))
  460.                 analyze-lambda-list))
  461. (defun analyze-lambda-list (lambda-list)
  462.   (declare (values nrequired noptional keysp restp allow-other-keys-p
  463.                    keywords keyword-parameters))
  464.   (flet ((parse-keyword-argument (arg)
  465.        (if (listp arg)
  466.            (if (listp (car arg))
  467.            (caar arg)
  468.            (make-keyword (car arg)))
  469.            (make-keyword arg))))
  470.     (let ((nrequired 0)
  471.       (noptional 0)
  472.       (keysp nil)
  473.       (restp nil)
  474.       (allow-other-keys-p nil)
  475.       (keywords ())
  476.       (keyword-parameters ())
  477.       (state 'required))
  478.       (declare (type index   nrequired noptional)
  479.                (type boolean keysp restp allow-other-keys-p)
  480.                (type list    keywords keyword-parameters))
  481.       (dolist (x lambda-list)
  482.     (if (memq x lambda-list-keywords)
  483.         (case x
  484.           (&optional         (setq state 'optional))
  485.           (&key              (setq keysp 't
  486.                        state 'key))
  487.           (&allow-other-keys (setq allow-other-keys-p 't))
  488.           (&rest             (setq restp 't
  489.                        state 'rest))
  490.           (&aux              (return t))
  491.           (otherwise
  492.         (error "Encountered the non-standard lambda list keyword ~S." x)))
  493.         (ecase state
  494.           (required  (incf nrequired))
  495.           (optional  (incf noptional))
  496.           (key       (push (parse-keyword-argument x) keywords)
  497.              (push x keyword-parameters))
  498.           (rest      ()))))
  499.       (values nrequired noptional keysp restp allow-other-keys-p
  500.           (reverse keywords)
  501.           (reverse keyword-parameters)))))
  502.  
  503. (defun keyword-spec-name (x)
  504.   (let ((key (if (atom x) x (car x))))
  505.     (if (atom key)
  506.     (intern (symbol-name key) (find-package "KEYWORD"))
  507.     (car key))))
  508.  
  509. (defun ftype-declaration-from-lambda-list (lambda-list #+cmu name)
  510.   (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p
  511.                   keys keyword-parameters)
  512.       (analyze-lambda-list lambda-list)
  513.     (declare (type index   nrequired noptional)
  514.              (type boolean keysp restp #+cmu allow-other-keys-p)
  515.              (type list    keys))
  516.     (declare (ignore keyword-parameters #-cmu allow-other-keys-p))
  517.     (let* (#+cmu (old (c::info function type name))
  518.        #+cmu (old-ftype (if (c::function-type-p old) old nil))
  519.        #+cmu (old-restp (and old-ftype (c::function-type-rest old-ftype)))
  520.        #+cmu (old-keys (and old-ftype
  521.                 (mapcar #'c::key-info-name
  522.                     (c::function-type-keywords old-ftype))))
  523.        #+cmu (old-keysp (and old-ftype (c::function-type-keyp old-ftype)))
  524.        #+cmu (old-allowp (and old-ftype (c::function-type-allowp old-ftype)))
  525.        (keywords #+cmu (union old-keys (mapcar #'keyword-spec-name keys))
  526.              #-cmu (mapcar #'keyword-spec-name keys)))
  527.       (declare (type list keywords))
  528.       `(function ,(append (make-list nrequired :initial-element 't)
  529.               (when (plusp noptional)
  530.                 (append '(&optional)
  531.                     (make-list noptional :initial-element 't)))
  532.               (when (or restp #+cmu old-restp)
  533.                 '(&rest t))
  534.               (when (or keysp #+cmu old-keysp)
  535.                             #+cmu
  536.                 (append '(&key)
  537.                     (mapcar #'(lambda (key)
  538.                         `(,key t))
  539.                         keywords)
  540.                     (when (or allow-other-keys-p #+cmu old-allowp)
  541.                       '(&allow-other-keys)))
  542.                             #-cmu
  543.                 (append '(&key)
  544.                                      (make-list (length keywords)
  545.                                                 :initial-element T))))
  546.          #-(or cmu kcl) T
  547.          #+(or cmu kcl) *))))
  548.  
  549. (defun proclaim-function (name lambda-list
  550.                           &optional (return-type #+(or cmu kcl) '*
  551.                                                  #-(or cmu kcl) T))
  552.   (unless (function-ftype-declaimed-p name)
  553.     (eval `(declaim (ftype (function
  554.                               ,(mapcar #'(lambda (param)
  555.                                            (if (memq param lambda-list-keywords)
  556.                                                param
  557.                                                T))
  558.                                        lambda-list)
  559.                               ,return-type)
  560.                             ,name)))
  561.     #+kcl (setf (get name 'compiler::proclaimed-closure) t)))
  562.  
  563. (defun proclaim-defgeneric (spec lambda-list)
  564.   (when (consp spec)
  565.     (setq spec (get-setf-function-name (cadr spec))))
  566.   (unless (function-ftype-declaimed-p spec)
  567.     (eval
  568.       `(declaim (ftype ,(ftype-declaration-from-lambda-list lambda-list #+cmu spec)
  569.                        ,spec)))
  570.     #+kcl (setf (get spec 'compiler::proclaimed-closure) t)))
  571.  
  572.